home *** CD-ROM | disk | FTP | other *** search
/ Info-Mac 1992 August / info-mac-1992.iso / Language (lang) / Lazy-Scheme / Compilo / Comp next >
Text File  |  1990-09-21  |  26KB  |  737 lines
  1. {••• Compilateur HELP-III •••}
  2.  
  3. (define (compile-expression exp f-env rbut cont mode)
  4.     (cond (constante? exp)
  5.            (compile-constant exp f-env rbut cont mode)
  6.           (variable? exp)
  7.            (compile-acces-variable exp f-env rbut cont mode)
  8.           (definition? exp)
  9.            (compile-definition exp f-env rbut cont mode)
  10.           (affectation? exp)
  11.            (compile-affectation exp f-env rbut cont mode)
  12.           (begin? exp)
  13.            (compile-begin exp f-env rbut cont mode)
  14.           (lambda? exp)
  15.            (compile-lambda exp f-env rbut cont mode)
  16.           (cond? exp)
  17.            (compile-cond exp f-env rbut cont mode)
  18.           (bindings? exp)
  19.            (compile-bindings exp f-env rbut cont mode)
  20.           (nomemo? exp)
  21.            (compile-nomemo exp f-env rbut cont mode)
  22.           (warn? exp)
  23.            (compile-warn exp f-env rbut cont mode)
  24.           (step-call? exp)
  25.            (compile-step exp f-env rbut cont mode)
  26.           (let? exp)
  27.            (compile-let exp f-env rbut cont mode)
  28.           (rec? exp)
  29.            (compile-rec exp f-env rbut cont mode)
  30.           (macro-exp? exp)
  31.            (compile-macro exp f-env rbut cont mode)
  32.           (ss-args? exp)
  33.            (compile-ss-args exp f-env rbut cont mode)
  34.           (application? exp)
  35.            (compile-application exp f-env rbut cont mode)
  36.           (error '?:syntx-er exp)))
  37.  
  38. (define (step? f e)
  39.   (not (or (number? f)
  40.            (constant? f)
  41.            (and (cons? f)(macro? (0 f))))))
  42.  
  43. (prinlength 1000)
  44. (prindepth 1000)
  45.  
  46. (define (cg e)
  47.     (compile-expression e '() 'R0 'return default-mode))
  48.  
  49. (define (cu e)
  50.     (compile-expression e '? 'R0 'return default-mode))
  51.  
  52. ;••• MODE •••
  53.  
  54. (define default-mode %000)
  55. (define nomemo-mode %100)
  56. (define step-mode %010)
  57. (define warn-mode %001)
  58.  
  59. (define (+mode am mode)
  60.   (bitor! am (bcopy mode)))
  61.  
  62. (define (-mode am mode)
  63.   (bitand! (bitnot! (bcopy am))(bcopy mode)))
  64.  
  65. ;••• CONTINUATION •••
  66.  
  67. (define (compile-cont  cont)
  68.   (cond 
  69.    (eq? cont 'next) (empty-pthunk)
  70.    (eq? cont 'return) (synt-rts)
  71.    (synt-bra cont)))
  72.  
  73. ;••• CONSTANTES •••
  74. (define (valeur k)
  75.   (eval k ()))
  76.  
  77. (define (every p l)
  78.   (cond (null? l) †
  79.         (p (0 l)) (every p (-1 l))))
  80.  
  81. (define (constante-simple? x)
  82.     (or (number? x)
  83.         (bitarray? x)
  84.         (cell? x)
  85.         (string? x)
  86.         (closure? x)
  87.         (environment? x)
  88.         (constant? x)
  89.         (quotee? x)))
  90.  
  91. (define (quotee? x)
  92.     (and (cons? x)
  93.          (eq? (0 x) 'quote)))
  94.  
  95. {(define (constante? x)
  96.   (or (constante-simple? x)
  97.       (and (cons? x) (every constante? x))))}
  98.  
  99. (define constante? constante-simple?)
  100.  
  101. (define (compile-constant k f-env rbut cont mode)
  102.     (add-source (append2pth (cond rbut (synt-move "L" (data (valeur k)) rbut)
  103.                                      (empty-pthunk))
  104.                             (compile-cont cont))
  105.                 (cons k f-env)))
  106.  
  107. ;••• Define •••
  108.  
  109. (define (definition? x)
  110.   (and (cons? x)
  111.        (eq? (0 x) 'define)))
  112.  
  113. (define (compile-definition exp f-env rbut cont mode)
  114.   (let [(exp2 (vardef2def (-1 exp)))]
  115.   (add-source
  116.       (appendpths
  117.              (compile-expression (1 exp2) f-env 'r0 'next mode)
  118.              (compile-glob-write (0 exp2) rbut cont))
  119.        (cons exp f-env))))
  120.  
  121. (define (vardef2def exp)
  122.   (cond (ident? (0 exp)) exp
  123.         (constant? (0 exp)) exp
  124.         (cons? (0 exp)) (list (0 (0 exp)) (cons 'lambda (cons (-1 (0 exp)) (-1 exp))))
  125.         (error '?:syntx-er exp)))
  126.  
  127. ;••• Variable •••
  128.  
  129. (define (variable? x)
  130.     (and (symbol? x)
  131.          (not (constant? x))))
  132.  
  133. ;si l'environnemnt est non défini, l'accés aux variables sera non lexical
  134. ;sinon, optimisation et accès via adresses lexicales
  135. ;si la valeur n'a pas de but - on ne compile que la continuation
  136. ; TBD: ceci est il en accord avec la sémantique de Help-Unau (forçage=>effets de bords possibles) ?
  137.  
  138. (define (compile-acces-variable v f-env rbut cont mode)
  139.   (append2pth
  140.       (add-strict (getlex v f-env))            ;this is Help-Unau !!!
  141.       (cond rbut
  142.         (compile-av-opt v f-env rbut cont mode)
  143.         (compile-cont cont))))
  144.  
  145. (define (compile-av-opt  v f-env rbut cont mode)
  146.     (let [(la (calcule-lex-address v f-env))]
  147.          (add-source (cond (error? la)(compile-lookup v rbut cont)
  148.                            (null? la) (append2pth (compile-glob-lookup v rbut)
  149.                                                   (compile-cont cont))
  150.                            (append2pth (compile-lex-lookup la rbut)
  151.                                        (compile-cont cont)))
  152.                      (cons v f-env))))
  153.  
  154. (define (compile-lookup v rbut cont)
  155.   (append2pth (synt-move "L" (data v) 'r0)
  156.               (cond (and (eq? rbut 'r0) (eq? cont 'return))
  157.                      (synt-callo thunk:lookvarval)
  158.                      (append2pth (synt-call thunk:lookvarval)
  159.                                  (synt-move "L" 'r0 rbut)))))
  160.  
  161. (define (compile-glob-lookup v rbut)
  162.   (append2pth (synt-move "L" (data v) 'r0)
  163.               (synt-move "L" '(4 r0) rbut)))
  164.  
  165. (define (compile-lex-lookup la rbut)
  166.   (cond (zero? (0 la)) (synt-move "L" `(,(+ 8 (* 4 (-1 la))) r2) rbut)
  167.         (appendpths (synt-move "L" '(4 r2) 'a1)
  168.                     (compile-frame-offset (1- (0 la)))
  169.                     (synt-move "L" `(,(+ 8 (* 4 (-1 la))) a1) rbut))))
  170.  
  171. (define (compile-frame-offset fo)
  172.   (cond (zero? fo) (empty-pthunk)
  173.         (append2pth (synt-move "L" '(4 A1) 'A1)
  174.                     (compile-frame-offset (1- fo)))))
  175.  
  176. (define (comp-force rf)
  177.   (let [(laf (cree-label "after-hold"))]
  178.        (appendpths (synt-btst 2 `(-4 ,rf))
  179.                    (synt-beq laf)
  180.                    (cond (eq? rf 'r0)(synt-call thunk:holdr0)
  181.                          (eq? rf 'a0)(synt-call thunk:holda0)
  182.                          (eq? rf 'a1)(synt-call thunk:holda1)
  183.                          (appendpths (synt-move "L" rf 'R0)
  184.                                      (synt-call thunk:holdr0)
  185.                                      (synt-move "L" 'r0 rf)))
  186.                    (synt-label laf))))
  187.  
  188.  ;••• affectation •••
  189.  
  190. (define (affectation? exp)
  191.   (and (cons? exp) (eq? (0 exp) '=!)))
  192.  
  193. (define (compile-affectation exp f-env rbut cont mode)
  194.   (let    [(la (calcule-lex-address (1 exp) f-env))
  195.            (t (compile-expression (2 exp) f-env 'r0 'next mode))]
  196.           (add-source
  197.               (append2pth
  198.                      t
  199.                      (cond (error? la)(compile-write (1 exp) rbut cont)
  200.                            (null? la) (compile-glob-write (1 exp) rbut cont)
  201.                                       (compile-lex-write la) rbut cont))
  202.                (cons exp f-env))))
  203.   
  204. (define (compile-write v rbut cont)
  205.   (append2pth (synt-move "L" (data v) 'a0)
  206.               (cond (and (eq? cont 'return)(eq? rbut 'r0))
  207.                (synt-callo thunk:valvarset)
  208.               (appendpths (synt-call thunk:valvarset)
  209.                           (synt-move "L" 'r0 rbut)
  210.                           (compile-cont cont)))))
  211.  
  212. (define (compile-glob-write v rbut cont)
  213.   (appendpths (synt-move "L" (data v) 'a1)
  214.               (synt-move "L" 'r0 '(4 a1))
  215.               (synt-move "L" 'r0 rbut)
  216.               (compile-cont cont)))
  217.  
  218. (define (compile-lex-write la rbut cont)
  219.   (cond (zero? (0 la)) (synt-move "L" 'r0 `(,(+ 8 (* 4 (-1 la))) r2))
  220.         (appendpths (synt-move "L" '(4 r2) 'a1)
  221.                     (compile-frame-offset (1- (0 la)))
  222.                     (synt-move "L" 'r0 `(,(+ 8 (* 4 (-1 la))) a1))
  223.                     (synt-move "L" 'r0 rbut)
  224.                     (compile-cont cont))))
  225.  
  226.  
  227. ;••• begin •••
  228.  
  229. (define (begin? exp)
  230.   (and (cons? exp) (eq? (0 exp) 'begin)))
  231.  
  232. (define (compile-begin exp f-env rbut cont mode)
  233.    (add-source (comp-begin (-1 exp) f-env rbut cont mode)
  234.                (cons exp f-env)))
  235.  
  236. (define (comp-begin exps f-env rbut cont mode)
  237.    (cond (null? exps) (compile-constant '? f-env rbut cont mode)
  238.          (null? (-1 exps)) (compile-expression (0 exps) f-env rbut cont mode)
  239.          (let [(t (compile-expression (0 exps) f-env ƒ 'next mode))]
  240.                     (cond (memq? 'm (mod t))
  241.                         (preservepth 'r2
  242.                                       t
  243.                                       (comp-begin (-1 exps) f-env rbut cont mode))
  244.                         (comp-begin (-1 exps) f-env rbut cont mode)))))
  245.  
  246. ;••• Lambda •••
  247.  
  248. (define (lambda? exp)
  249.   (and (cons? exp) (eq? (0 exp) 'lambda)))
  250.  
  251. (define (compile-lambda exp f-env rbut cont mode)
  252.   (cond rbut
  253.         (let [(f-env (etend-env f-env (1 exp)))]
  254.           (add-source (appendpths (compile-closure-make (1 exp) (compile-corps (-1 exp) f-env) f-env)
  255.                                   (synt-move "L" 'a0 rbut)
  256.                                   (compile-cont cont))
  257.                      exp))
  258.          (compile-cont cont)))
  259.  
  260. (define (compile-corps exp f-env)
  261.   (let [(t  (comp-begin (-1 exp) f-env 'R0 'return default-mode))]
  262.         (add-source (append2pth (compile-make-env (0 exp) t) t) (-1 exp))))
  263.  
  264. (define (compile-make-env l t)
  265.    (let [(at (clos-typar l 0))]
  266.         (cond (zero? (-1 at))
  267.                 (cond (zero? (0 at)) (empty-pthunk)
  268.                   (appendpths
  269.                     (cond (memq? 'e (nec t))
  270.                       (appendpths
  271.                         (synt-move "L" `(# ,(+ 3 (* 2 (0 at)))) 'd0)
  272.                         (synt-call thunk:getablock)
  273.                         (synt-move "B" `(# ,type:env) '(-3 a0)))
  274.                       (appendpths
  275.                         (synt-move "L" `(# ,(+ 3 (0 at))) 'd0)
  276.                         (synt-call thunk:getablock)
  277.                         (synt-move "B" `(# ,type:senv) '(-3 a0))))
  278.                     (synt-move "L" 'R2 '(4 a0))
  279.                     (synt-move "L" 'a0 'r2)
  280.                     (synt-lea '(8 a0) 'a0)
  281.                     (compile-pop l (memq? 'e (nec t)) (0 at))))
  282.                 (appendpths
  283.                  (compile-cons-extra (0 at))
  284.                  (cond (memq? 'e (nec t))
  285.                   (appendpths
  286.                    (synt-move "L" `(# ,(+ 5 (* 2 (0 at)))) 'd0)
  287.                    (synt-call thunk:getablock)
  288.                    (synt-move "B" `(# ,type:env) '(-3 a0)))
  289.                   (appendpths
  290.                    (synt-move "L" `(# ,(+ 4 (0 at))) 'd0)
  291.                    (synt-call thunk:getablock)
  292.                    (synt-move "B" `(# ,type:senv) '(-3 a0))))
  293.                  (synt-move "L" 'R2 '(4 a0))
  294.                  (synt-move "L" 'a0 'r2)
  295.                  (synt-lea '(8 a0) 'a0)
  296.                  (compile-pop l (memq? 'e (nec t))(1+ (0 at)))))))
  297.  
  298.  
  299. (define (compile-pop l f n)
  300.   (appendpths (compile-pops n)
  301.                (cond f
  302.                  (compile-fill (reverse l))
  303.                  (empty-thunk))
  304.                (synt-lea '(-4 LP) 'LP)))
  305.  
  306. (define (compile-pops n)
  307.    (cond (zero? n) (empty-pthunk)
  308.          (append2pth (synt-move "L" '(- LP) '(a0 +))
  309.                         (compile-pops (1- n)))))
  310.  
  311. (define (compile-fill l)
  312.     (cond (null? l) (empty-pthunk)
  313.           (append2pth (synt-move "L" (data (0 l)) '(a0 +))
  314.                       (compile-fill (-1 l)))))
  315.  
  316. (define (compile-closure-make l t f-env)
  317.     (appendpths (synt-move "L" `(# 4) 'D0)
  318.                 (synt-call thunk:getablock)
  319.                 (synt-move "B" `(# ,(type type)) '(-3 a0))
  320.                 (synt-move "L" 'r2 '(4 a0))
  321.                 (synt-move "L" (data t) '(a0))
  322.                 (synt-move "L" `(# ,(+ (arite l)(* 65536 (tobit f-env l (str t))))) '(8 a0))))
  323.  
  324. (define (tobit f-env l s)
  325.   (letrec [((loop s b)
  326.              (cond (null? s) b
  327.                    (eq? (-1 (0 s)) f-env) (loop (-1 s) (findvar (0(0 s)) l 1))
  328.                    (loop (-1 l) b)))
  329.            ((findvar v l n)
  330.               (cond (null? l) 0
  331.                     (eq? (0 l) v) n
  332.                     (findvar v (-1 l) (+ n n))))]
  333.            (loop s 0)))
  334.  
  335. (define (compile-cons-extra ar)
  336.   (let [(loop (cree-label "loop"))
  337.         (after-loop (cree-label "after-loop"))]
  338.        (appendpths (synt-move "L" (data ()) 'r0)
  339.                    (synt-sub "W" `(# ,ar) 'd1)
  340.                    (synt-move "W" 'd1 '(- sp))
  341.                    (synt-beq after-loop)
  342.                    (synt-label loop)
  343.                    (synt-move "L" '(# 3) 'd0)
  344.                    (synt-call thunk:getablock)
  345.                    (synt-move "L" 'r0 '(4 a0))
  346.                    (synt-move "L" 'a0 'r0)
  347.                    (synt-move "L" '(- lp) '(r0))
  348.                    (synt-sub "W" '(# 1) '(sp))
  349.                    (synt-bpl loop)
  350.                    (synt-label after-loop)
  351.                    (synt-lea '(4 SP) 'Sp)
  352.                    (synt-move "L" 'r0 '(LP +)))))
  353.  
  354. (define (arite l)
  355.   (let [(at (clos-typar l 0))]
  356.        (coerce (bitor! (coerce (0 at) 3)
  357.                        (coerce (* 256 (-1 at)) 3)) 1)))
  358.     
  359. (define (clos-typar c a)
  360.    (cond (null? c) (cons a 0)
  361.          (ident? c) (cons a 1)
  362.          (and (cons? c)(ident? (0 c))) (clos-typar (-1 c) (1+ a))
  363.          (error '?:syntx-er c)))
  364.  
  365. ;••• Cond •••
  366.  
  367. ;même si en Help, cond p.e vu comme une closure, on le compile ici (rapidité)
  368.  
  369. (define (cond? exp)
  370.   (and (cons? exp) (eq? (0 exp) 'cond)))
  371.  
  372. (define (compile-cond exp f-env rbut cont mode)
  373.   (cond (eq? cont 'next)
  374.          (let [(fin (cree-label "apres-cond"))]
  375.            (append2pth (compile-clauses (-1 exp) f-env rbut fin mode)
  376.                         (synt-label fin)))
  377.         (compile-clauses (-1 exp) f-env rbut cont mode)))
  378.  
  379. (define (compile-clauses exp f-env rbut cont mode)
  380.   (cond (null? exp) (compile-constant ƒ f-env rbut cont mode)
  381.         (null? (-1 exp)) (appendpths (compile-expression (0 exp) f-env 'r0 'next mode)
  382.                                       (comp-force 'r0)
  383.                                       (synt-move "L" 'r0 rbut)
  384.                                       (compile-cont cont))
  385.         (compile-clause
  386.           (0 exp)
  387.           (1 exp)
  388.           (-2 exp)
  389.           {(cree-label "cond-undef")}
  390.           f-env
  391.           rbut
  392.           cont
  393.           mode)))
  394.  
  395. (define (compile-clause test action others f-env rbut cont mode)
  396.   (cond (constante? test)
  397.           (cond (true? test)
  398.                  (compile-expression action f-env rbut cont mode)
  399.                  (compile-clauses others f-env rbut cont mode))
  400.        (let [(t-act (compile-expression action f-env rbut cont mode))
  401.              (t-tst (append2pth (compile-expression test f-env 'r0 'next mode)
  402.                                 (comp-force 'r0)))
  403.              (t-oth (compile-clauses others f-env rbut cont mode))
  404.              (l-fls (cree-label "cond-faux"))]
  405.             (preservepth 'r2
  406.                          t-tst
  407.                          (append2pth (compile-test "L" 'r0 (data ƒ) l-fls)
  408.                                      (undes2pth (append2pth t-act (synt-label l-fls))
  409.                                                 t-oth))))))
  410. (define (true? exp)
  411.    (neq? (valeur exp) ƒ))
  412.  
  413. (define (compile-test s m1 m2 l)
  414.    (append2pth (synt-cmp s m1 m2)
  415.                (synt-beq l)))
  416.  
  417. ;••• bindings •••
  418.  
  419. (define (bindings? exp)
  420.   (cond (cons? exp) (eq? (0 exp) 'bindings)))
  421.  
  422. (define (compile-bindings exp f-env rbut cont mode)
  423.     (add-source
  424.       (cond rbut
  425.         (appendpths (synt-move "L" 'r2 rbut)
  426.                     (add-info '(e)()())
  427.                     (compile-cont cont))
  428.         (compile-cont cont))
  429.                 (cons exp f-env)))
  430.  
  431. ;••• Macros •••
  432.  
  433. (define (macro-exp? exp)
  434.   (cond (cons? exp) (macro? (0 exp))))
  435.  
  436. (define (compile-macro exp f-env rbut cont mode)
  437.   (add-source (compile-expression (expand exp) f-env rbut cont mode) (cons exp f-env)))
  438.  
  439. ;••• NoMemo •••
  440.  
  441. (define (nomemo? exp)
  442.   (and (cons? exp) (eq? (0 exp) 'nomemo)))
  443.  
  444. (define (compile-nomemo exp f-env rbut cont mode)
  445.  (add-source
  446.   (cond (constante? exp)(compile-constant exp f-env rbut cont mode)
  447.         (quotee? exp)(compile-quotee exp f-env rbut cont mode)
  448.         (let [(t (compile-expression (cons 'begin (-1 exp)) f-env rbut cont mode))]
  449.              (appendpths (synt-move "L" 'D7 '(- sp))
  450.                          (synt-bset 31 'D7)
  451.                          (compile-susp t rbut cont)
  452.                          (synt-move "L" '(sp +) 'D7)))) (cons exp f-env)))
  453.  
  454. ;••• warn •••
  455.      
  456. (define (warn? exp)
  457.   (and (cons? exp) (eq? (0 exp) 'warn)))
  458.  
  459. (define (compile-warn exp f-env rbut cont mode)
  460.  (add-source
  461.   (appendpths (synt-move "L" 'D7 '(- sp))
  462.               (synt-move "B" (cond (eq? (1 exp) ƒ)  '(# 0)
  463.                                    (eq? (1 exp) ()) '(# -1)
  464.                                    '(# 1)) 'D7)
  465.               (compile-expression (cons 'begin (-1 exp)) f-env rbut cont mode)
  466.               (synt-move "L" '(sp +) 'd7)) (cons exp f-env)))
  467.  
  468. ;••• Step •••
  469.      
  470. (define (step-call? exp)
  471.   (and (cons? exp) (eq? (0 exp) 'step)))
  472.  
  473. (define (compile-step exp f-env rbut cont mode)
  474.   )
  475.  
  476. ;••• let •••
  477.      
  478. (define (let? exp)
  479.   (and (cons? exp) (eq? (0 exp) 'let)))
  480.  
  481. (define (compile-let exp f-env rbut cont mode)
  482.   )
  483.  
  484. ;••• Letrec •••
  485.      
  486. (define (rec? exp)
  487.   (and (cons? exp) (eq? (0 exp) 'letrec)))
  488.  
  489. (define (compile-rec exp f-env rbut cont mode)
  490.   )
  491.  
  492. ;••• Application sans args •••
  493.  
  494. (define (ss-args? exp)
  495.   (and (cons? exp) (null? (-1 exp))))
  496.  
  497. (define (compile-ss-args exp f-env rbut cont mode)
  498.   (add-source
  499.    (cond {(lambda? (0 exp)) (compile-let (lambda2let exp) f-env rbut cont mode)}
  500.          (constante? (0 exp)) (compile-opt-ss-args  (valeur (0 exp)) f-env rbut cont mode)
  501.          (quotee? (0 exp)) (compile-opt-ss-args (1 (0 exp)) f-env rbut cont mode)
  502.          (compile-noopt-ss-arg exp f-env rbut cont mode))
  503.   exp))
  504.  
  505. (define (compile-noopt-ss-arg exp f-env rbut cont mode)
  506.   (appendpths (compile-expression (0 exp) f-env 'r0 'next mode)
  507.               (synt-move "L" 'r0 '(LP +))
  508.               (synt-move "L" 'lp '(- SP))
  509.               (synt-move "W" '(# 0) 'd1)
  510.               (cond (and (eq? cont 'return)(eq? rbut 'r0))
  511.                      (synt-callo thunk:applyit)
  512.                      (appendpths (synt-call thunk:applyit)
  513.                                  (synt-move "L" 'r0 rbut)
  514.                                  (compile-cont cont)))))
  515.  
  516. (define (compile-opt-ss-args f f-env rbut cont mode)
  517.   (cond (=? (type f) 1) (error '?:few-args f)
  518.         (closure? f) (letrec [(at (getaritype f))
  519.                               (type (modulo at 256))
  520.                               (ari  (/ at 256))]
  521.                           (cond (<>? ari 0) (error '?:few-args f)
  522.                                 (=? type 0) (compile-procn-call-ss f cont rbut)
  523.                                 (compile-nproc-call-ss f cont rbut)))
  524.         (error '? (list "ne sais pas compiler1" f))))
  525.  
  526. (define (compile-procn-call-ss f cont rbut)
  527.   (appendpths (synt-move "L" (data f) 'a0)
  528.               (synt-move "L" 'a0 '(LP +))
  529.               (synt-move "L" '(4 a0) 'r2)
  530.               (synt-move "L" '(a0) 'a0)
  531.               (cond (and (eq? cont 'return)
  532.                          (eq? rbut 'r0)) (synt-jmp '(8 a0))
  533.                     (appendpths (synt-jsr '(8 a0))
  534.                                 (synt-move "L" 'r0 rbut)
  535.                                 (compile-cont cont)))))
  536.  
  537.  
  538. (define (compile-nproc-call-ss f cont rbut)
  539.   (appendpths (synt-move "L" (data f) 'a0)
  540.               (synt-move "L" 'a0 '(LP +))
  541.               (synt-move "L" (data '()) '(LP +))
  542.               (synt-move "W" '(# 0) 'd1)
  543.               (synt-move "L" '(4 a0) 'r2)
  544.               (synt-move "L" '(a0) 'a0)
  545.               (cond (and (eq? cont 'return)
  546.                          (eq? rbut 'r0)) (synt-jmp '(8 a0))
  547.                     (appendpths (synt-jsr '(8 a0))
  548.                                 (synt-move "L" 'r0 rbut)
  549.                                 (compile-cont cont)))))
  550.                   
  551. ;••• Application avec args •••
  552.  
  553. (define (application? exp)
  554.   (cons? exp))
  555.  
  556. (define (compile-application exp f-env rbut cont mode)
  557.   (add-source
  558.    (cond {(lambda? (0 exp)) (compile-let (lambda2let exp) f-env rbut cont mode)}
  559.          (constante? (0 exp)) (compile-opt-app (valeur (0 exp)) (-1 exp) f-env rbut cont mode)
  560.          (quotee? (0 exp)) (compile-opt-app (1 (0 exp))(-1 exp) f-env rbut cont mode)
  561.          (compile-noopt-app exp f-env rbut cont mode))
  562.    exp))
  563.  
  564. (define (compile-noopt-app exp f-env rbut cont mode)
  565.   (append2pth
  566.     (preservepth 'r2
  567.                  (compile-expression (0 exp) f-env 'r0 'next mode)
  568.                  (appendpths (synt-move "L" 'r0 '(LP +))
  569.                              (synt-move "L" 'LP '(- SP))
  570.                              (push-thunks (-1 exp) f-env mode)
  571.                              (synt-move "W" (list '# (length (-1 exp))) 'd1)))
  572.     (cond (and (eq? cont 'return)(eq? rbut 'r0))
  573.            (synt-callo thunk:susp&apply)
  574.            (appendpths (synt-call thunk:susp&apply)
  575.                        (synt-move "L" 'r0 rbut)
  576.                        (compile-cont cont)))))
  577.   
  578. (define (push-thunks args f-env mode)
  579.   (cond (null? args) (empty-pthunk)
  580.         (append2pth (synt-move "L"
  581.                                (data (compile-expression (0 args) f-env 'r0 'return mode))
  582.                                '(LP +))
  583.                     (push-thunks (-1 args) f-env mode))))
  584.   
  585. (define (compile-opt-app f arg f-env rbut cont mode)
  586.   (cond (=? (type f) 1) (compile-select f arg f-env rbut cont mode)
  587.         (closure? f) (compile-clos-app f arg f-env rbut cont mode)
  588.         (error '? (list "sais pas compiler2" (cons f arg)))))
  589.  
  590. (define (compile-select f arg f-env rbut cont mode)
  591.   (error '? (list "sais pas compiler2" (cons f arg))))
  592.   
  593. (define (compile-clos-app f arg f-env rbut cont mode)
  594.   (letrec [(at (getaritype f))
  595.            (type (modulo at 256))
  596.            (ari  (/ at 256))
  597.            (narg (length arg))]
  598.           (cond (=? type 0) (cond (=? narg ari) (compile-procn-call f arg cont rbut f-env mode)
  599.                                   (>? narg ari) (error '?:too-args (cons f arg))
  600.                                   (<? narg ari) (error '?:few-args (cons f arg)))
  601.                 (>? narg ari)(compile-nproc-call f arg cont rbut f-env mode)
  602.                 (=? narg ari)(compile-nproc-call f arg cont rbut f-env mode)
  603.                 (error? '?:few-args (cons f arg)))))
  604.  
  605. (define (compile-procn-call f args cont rbut f-env mode)
  606.   (appendpths (synt-move "L" (data f) '(lp +))
  607.               (push-args2 (getstrict f) args f-env mode)
  608.               (synt-move "L" (data f) 'a0)
  609.               (synt-move "L" '(4 a0) 'r2)
  610.               (synt-move "L" '(a0) 'a0)
  611.               (cond (and (eq? cont 'return)
  612.                          (eq? rbut 'r0)) (synt-jmp '(8 a0))
  613.                     (appendpths (synt-jsr '(8 a0))
  614.                                 (synt-move "L" 'r0 rbut)
  615.                                 (compile-cont cont)))))
  616.  
  617. (define (push-args2 s args f-env mode)
  618.   (letrec [((loop s arg n)
  619.               (cond (null? arg)
  620.                      (empty-pthunk)
  621.                     (n s)
  622.                     (preservepth 'r2
  623.                                   (compile-expression (0 arg) f-env '(lp +) 'next mode)
  624.                                   (append2pth
  625.                                      (cond (variable? (0 arg)) 
  626.                                             (add-strict (getlex (0 arg) f-env))
  627.                                             (empty-pthunk))
  628.                                   (loop s (-1 arg) (cond (=? n 15) 15 (1+ n)))))
  629.                     (appendpths (compile-chilled (0 arg) f-env '(lp +) 'next mode)
  630.                                 (loop s (-1 arg) (cond (=? n 15) 15 (1+ n))))))]
  631.           (loop s args 0)))
  632.  
  633. (define (compile-nproc-call f args cont rbut f-env mode)
  634.   (appendpths (synt-move "L" (data f) '(lp +))
  635.               (push-args2 (getstrict f) args f-env mode)
  636.               (synt-move "L" (data f) 'a0)
  637.               (synt-move "L" '(4 a0) 'r2)
  638.               (synt-move "L" '(a0) 'a0)
  639.               (synt-move "W" `(# ,(length args)) 'd1)
  640.               (cond (and (eq? cont 'return)
  641.                          (eq? rbut 'r0)) (synt-jmp '(8 a0))
  642.                     (appendpths (synt-jsr '(8 a0))
  643.                                 (synt-move "L" 'r0 rbut)
  644.                                 (compile-cont cont)))))
  645.  
  646. ;••• Paresse •••
  647.  
  648. (define (compile-chilled exp f-env rbut cont mode)
  649.   (cond (constante? exp)(compile-constant exp f-env rbut cont mode)
  650.         (quotee? exp)(compile-quotee exp f-env rbut cont mode)
  651.         (let [(t (compile-expression exp f-env rbut 'return mode))]
  652.                  (compile-susp t rbut cont))))
  653.  
  654. (define (compile-susp t rbut cont)
  655.   (appendpths (synt-move "L" '(# 4) 'd0)
  656.               (synt-call thunk:getablock)
  657.               (synt-move "W" `(# ,(+ 1024 type:susp)) '(-4 a0))
  658.               (synt-move "L" (data t) '(a0))
  659.               (synt-move "L" 'r2 '(4 a0))
  660.               (synt-move "L" 'D7 '(8 a0))
  661.               (synt-move "L" 'a0 rbut)
  662.               (compile-cont cont)))
  663.  
  664. ;••• labels •••
  665.  
  666. ;un label sera le cons de 'label et de la chaîne
  667. ;c'est l'adresse du cons formé qui indiquera le label
  668.  
  669. (define (cree-label s)
  670.   (cons 'label s))
  671.  
  672. ;••• Xrefs •••
  673.  
  674. ;on peut xrefer une donnée (data)
  675.  
  676. (define (data o)
  677.         (list 'data o))
  678.  
  679. (define (data? u)
  680.   (and (cons? u)
  681.        (eq? (0 u) 'data)))
  682.  
  683. ;••• TYPES •••
  684.  
  685. (define type:env 16)
  686. (define type:senv 17)
  687. (define type:susp 20)
  688.  
  689. ;••• Divers •••
  690.  
  691. (define (union-set e f)
  692.     (cond (null? e) f
  693.           (memq? (0 e) f)(union-set (-1 e) f)
  694.           (cons (0 e) (union-set (-1 e) f))))
  695.  
  696. (define (union-tout l)
  697.     (cond (null? l) ()
  698.         (union-set (0 l) (union-tout (-1 l)))))
  699.  
  700. (define (differ-set e f)
  701.     (cond (null? e) '()
  702.           (memq? (0 e) f)(differ-set (-1 e) f)
  703.           (cons (0 e) (differ-set (-1 e) f))))
  704.  
  705. (define (inter-set e f)
  706.     (cond (null? e) '()
  707.           (memq? (0 e) f)(cons e (inter-set (-1 e) f))
  708.           (inter-set (-1 e) f)))
  709.  
  710. ;••• Environnements •••
  711. ;nous représenterons le "futur env" par une cellule
  712. ;1er élém:next frame ou () ou ?
  713. ;suite:les variables
  714.  
  715. (define (etend-env env lv)
  716.   (apply cell (cons env (reverse lv))))
  717.  
  718. ;••• calcule le Frame Offset et le Var Offset…dans l'environnement futur •••
  719.  
  720. (define (calcule-lex-address var f-env)
  721.     (CalcLex var f-env 0 0))
  722.  
  723. (define (CalcLex var f-env fo vo)
  724.     (cond (null? f-env) ()
  725.           (eq? f-env '?) '?
  726.           (=? (blength f-env) (+ 2 vo)) (CalcLex var (0 f-env) (1+ fo) 0)
  727.           (eq? ((1+ vo) f-env) var) (cons fo vo)
  728.           (CalcLex var f-env fo (1+ vo))))
  729.  
  730. (define (getlex var f-env)
  731.    (letrec [((getenv f-env vo)
  732.                (cond (null? f-env) ()
  733.                      (eq? f-env '?) '?
  734.                      (=? (blength f-env) (+ 2 vo)) (getenv (0 f-env) 0)
  735.                      (eq? ((1+ vo) f-env) var) f-env
  736.                      (getenv f-env (1+ vo))))]
  737.            (cons var (getenv f-env 0))))